home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / DEPAL.ZIP / SOURCE.ZIP / PED.BAS < prev    next >
BASIC Source File  |  1995-03-13  |  2KB  |  84 lines
  1. Option Explicit
  2.  
  3. Global filename As String
  4. Global Directory As String
  5. Global Drivename As String
  6. Global FilePath As String
  7. Global Pathname As String
  8. Global Success As Integer
  9.  
  10. '================ Dither236 ==========================
  11. '
  12. '   this will dither an image to the middle 236 colors
  13. '   of a palette using the Floyd Steinberg algorithm
  14. '   with an error damping threshhold of 8
  15. '
  16. Sub Dither236 (ctl As control, ByVal palette As Integer)
  17.     
  18.     Dim i As Integer
  19.     ReDim ignore(0 To 255) As Integer
  20.  
  21.     For i = 0 To 9
  22.         ignore(i) = 2
  23.     Next i
  24.     For i = 246 To 255
  25.         ignore(i) = 2
  26.     Next i
  27.     Call Dither(ctl, ignore(), palette, 8)
  28.     Erase ignore
  29.  
  30. End Sub
  31.  
  32. Sub ReadPalette (Pal As control, filename As String)
  33.  
  34.     Open filename For Input As #1
  35.     Dim i As Integer, inx As Integer
  36.     Dim red As Integer, green As Integer, blue As Integer
  37.     Dim Color As Long
  38.     While Not EOF(1)
  39.         Input #1, red, green, blue, inx
  40.         Pal.Cindex = inx
  41.         Pal.Color = RGB(red, green, blue)
  42.     Wend
  43.     Close #1
  44.  
  45. End Sub
  46.  
  47. '================= Remap236 ==========================
  48. '
  49. '   this will remap an image to the middle 236 colors
  50. '   of a palette using closest color matching.
  51. '
  52. Sub Remap236 (ctl As control, ByVal palette As Integer)
  53.     
  54.     Dim i As Integer
  55.     ReDim ignore(0 To 255) As Integer
  56.  
  57.     For i = 0 To 9
  58.         ignore(i) = 2
  59.     Next i
  60.     For i = 246 To 255
  61.         ignore(i) = 2
  62.     Next i
  63.     Call Remap(ctl, ignore(), palette)
  64.     Erase ignore
  65.  
  66. End Sub
  67.  
  68. Sub WritePalette (Pal As control, filename As String)
  69.     
  70.     Open filename For Output As #1
  71.     Dim i As Integer
  72.     Dim red As Integer, green As Integer, blue As Integer
  73.     Dim Color As Long
  74.     For i = 0 To 255
  75.         Pal.Cindex = i
  76.         Color = Pal.Color
  77.         Call GetRGB(Color, red, green, blue)
  78.         Print #1, red, green, blue, i
  79.     Next
  80.     Close #1
  81.  
  82. End Sub
  83.  
  84.